The 640 MEG Shareware Studio 2/The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO/pascal/ghostbbs.zip/BB3.PAS

Pascal/Delphi Source File | 1980-01-01 | 35KB | 1,184 lines

{ I was getting close to bumping up on the 64K limit  (though Im not
  there yet), so i left procedures sysoponly and filesys as
  overlay procedures }

procedure sysoponly;
{ allows sysop to edit user stats and parms from local
  or remote location.                                  }
  var temp: char;
      temprec : sysid;
      editno : integer;

  procedure display_user;
  { display pertinent user stats on screen for editing }
  var s:longname;
  begin
     with temprec do
       begin
         clearsc;
         lineout('Editing user #'+itoa(editno));
         if intlg = '***' then lineout('Not yet verified')
           else lineout('Verified '+intlg);
         lineout('1.) Name           '+user);
         lineout('2.) Realname       '+user2);
         lineout('3.) Password       '+pass);
         lineout('4.) Street Address '+addr);
         lineout('5.) City           '+city);
         lineout('6.) State & Zip    '+szip);
         lineout('7.) Phone number   '+phnn);
         lineout('8.) Last log on    '+lsto);
         lineout('9.) Access level   '+itoa(acc));
         lineout('10.) Spec. access  '+itoa(speca));
         lineout('11.) Downloads     '+itoa(dld));
         lineout('12.) Uploads       '+itoa(uld));
         lineout('13.) Msgs posted   '+itoa(mptd));
         lineout('14.) Times on      '+itoa(lgdn));
       end;
  end;

  procedure edit_stats(number:integer);
  var i,j: integer;
      s  : longname;
      ch : char;
  begin
    editno := number;
    display_user;
    repeat
      s := allcaps(getinput('[E]dit [S]ave [A]bort re[F]resh [R]emove [V]erify ',1,echo));
      ch := s[1];
      if ch = 'F' then display_user;
      if ch = 'V'
        then begin
          clock(year,month, date, hour, min);
          temprec.intlg := time(year,month, date, hour, min);
          temprec.acc := reg;
        end;
      if ch = 'S' then
        begin
          assign(idfile, 'IDS.BBS');
          reset(idfile);
          seek(idfile, number);
          write(idfile, temprec);
          close(idfile);
        end;
      if ch = 'R' then
        begin
          with temprec do
            begin
              user := space;
              user2 := space;
              addr := space;
              city := space;
              szip := space;
              phnn := space;
              lsto := space;
              dld := 0;
              uld := 0;
              mptd := 0;
              lgdn := 0;
              fillchar(lstm,sizeof(lstm),#0);
              pass := '***';
              intlg := '***';
              acc := 0;
              speca := 0;
            end;
          assign(idfile, 'IDS.BBS');
          reset(idfile);
          seek(idfile, number);
          write(idfile, temprec);
          close(idfile);
        end;
      if ch = 'E' then
        begin
          repeat
            i := getint(14,0,'Edit which? ');
              case i of
                1..8 : s:=allcaps(getinput('New ',25,echo));
                9    :  j:=getint(5,0,'New ');
                10..14: j:=getint(255,0,'New ');
              end; {case}
              with temprec do
                case i of
                  1 :  user := s;
                  2 :  user2 := s;
                  3 :  pass := s;
                  4 :  addr := s;
                  5 :  city := s;
                  6 :  szip := s;
                  7 :  phnn := s;
                  8 :  lsto := s;
                  9 :  acc := j;
                  10:  speca := j;
                  11:  dld := j;
                  12:  uld := j;
                  13:  mptd := j;
                  14:  lgdn := j;
                end; {case}
          until ((i = 0) or (not cts));
        end;
    until ((ch in ['A','S','R']) or (not cts));
  end;

  procedure edit_user;
    var
     errcode, number: integer;
     temp: longname;
     found : boolean;
    begin
      repeat
        found := false;
        temp := allcaps(getinput('User name or # ? ',25,echo));
        val(temp,number,errcode);
        if errcode = 0 then found := true
                       else find_name(temp,number,found);
        editno := number;
        if found
          then begin
          assign(idfile, 'IDS.BBS');
          reset(idfile);
          seek(idfile, number);
          {$I-}
          read(idfile, temprec);
          {$I+}
          if ioresult <> 0 then found := false;
          close(idfile);
        end;
        if (found and (temp <> '')) then edit_stats(number)
                                    else lineout(temp + ' Not found ');
      until ((temp = '') or (not cts));
    end;

procedure verify_users;
var number: integer;
    s :  name;
    ch, ch1 : char;
begin
  repeat
    s:=allcaps(getinput('A)ll or N)ew ',10,echo));
    ch := s[1];
  until ((ch in ['A','N']) or (not cts));
  number := 0;
  while  ((ch1 <> 'N') and cts ) do
  begin
    assign(idfile,'IDS.BBS');
    reset(idfile);
    seek(idfile,number);
    {$I-}
    read(idfile,temprec);
    {$I+}
    if ioresult <> 0 then
      begin
        close(idfile);
        exit;
      end;
    close(idfile);
    if ((ch = 'N') and ( temprec.intlg = '***') and (temprec.pass <> '***')) then edit_stats(number);
    if (ch = 'A') then edit_stats(number);
    number := number + 1;
    if ch = 'A' then ch1 := getcap('Continue (Y/N) ? ');
  end;
end;

  begin { sysoponly }
    repeat
      temp := getcap('[E]dit, [V]erify, [R]ead Log ? ');
      case temp of
        'E': edit_user;
        'V': verify_users;
        'R': read_userlog;
      end;
    until not ((temp in ['C','E','R']) and cts);
  end;

overlay procedure filesys;
{ does all the xmodem u/d loads and ascii file transfers}
  const
    soh = 1;
    eot = 4;
    ack = 6;
    nak = $15;
    can = $18;
    C   = $43;
    maxnumfilesects = 20;

type
 str40  = string[40];
 str30  = string[30];
 str20  = string[20];
 sect1  = record
              sectt       : str30;
              secdir      : str40;
              sect_access : byte;
              spec_access : byte;
         end;

 sectname = array[1..maxnumfilesects] of sect1;

    channel = array[0..127] of byte;

  var
    sect : sectname;
    filebuff: array [0..16] of channel;
    datafile: file;
    chksum: byte;
    CRC: integer;
    crcmode: boolean;
    comch: char;
    filename : line;
    sectnum : byte;

procedure getsects;
var textfile : text;
    loop : byte;
begin
assign(textfile,'bbsinfo\files.cnf');
reset(textfile);
for loop := 1 to numfilesects do
  begin
    readln(textfile,sect[loop].sectt);
    readln(textfile,sect[loop].secdir);
    read(textfile,sect[loop].sect_access);
    readln(textfile,sect[loop].spec_access);
  end;
close(textfile);
end;

  procedure xmit(x:byte);
    begin
      xmitchar(chr(x));
    end;

  function inbyte: byte;
    var temp: char;
    begin
      repeat until inready or not cts;
      if keypressed then read(kbd, temp) else temp := recvchar;
      inbyte := ord(temp);
    end;

  procedure calcCRC(data:byte);
    var
      carry: boolean;
      i: byte;
    begin
      chksum := lo(chksum + data);
      for i := 0 to 7 do begin
        carry := (crc and $8000) <> 0;
        crc := crc shl 1;
        if (data and $80) <> 0 then crc := crc or $0001;
        if carry then crc := crc xor $1021;
        data := lo(data shl 1);
      end;
    end;

  procedure sendcalc(ch : byte);
    begin
      xmit(ch);
      calcCRC(ch);
    end;

  procedure acknak(var inch: byte; time: integer);
    var loop, loopend: integer;
    begin
      loopend := 100 * time;
      loop := 0;
      inch := 0;
      repeat
        delay(10);
        if inready then inch := inbyte;
        loop :=loop + 1;
      until (inch in [ack, nak, can, C]) or (loop >= loopend) or not cts;
    end;

  function acknakout(ch : byte): boolean;
    var  times, loops: integer;
    begin
      times := 0;
      repeat
        loops := 0;
        xmit(ch);
        while (loops < 10) and not timedin do loops := loops + 1;
        times := times + 1;
      until inready or (times > 9) or not cts;
      acknakout := inready and cts;
    end;

  procedure download(var successful: boolean);
    var
      inch, loop: byte;
      blocknum, period, tries: integer;
      done: boolean;
      temp: line;
      dtime, dsize: real;
    begin
      reset(datafile);
      dsize := longfilesize(datafile);
      dtime := (dsize * 1.30 * 1200/baud) / 60;
      lineout('Ready for XMODEM transfer:');
      str(dsize:8:0, temp);
      lineout('File open:' + temp + ' Blocks');
      str(dtime:3:2, temp);
      lineout('Download Time is approx. ' + temp + ' Minutes.');
      calcconnect(usehour,usemin);
      if ((((usehour * 60) + (today_timeon +usemin)) > (maxminon - dtime))
             and (access < prefuser))
        then begin
          lineout(space);
          lineout('Sorry Swab, You don''t have enough time left');
          successful := false;
          close(datafile);
          exit;
        end;
      lineout('To cancel: type CTL-X until you return to command prompt.');
      blockread(datafile, filebuff[0], 1);
      done := false;
      tries := 0;
      blocknum := 1;
      crcmode := false;
      repeat
        acknak(inch, 60);
        if inch = 0 then inch := can;
        if inch = C then begin
          crcmode := true;
          writeln('CRC mode requested');
        end;
        if inch = ack then begin
          if eof(datafile) then done := true else begin
            write(cr + 'Sent #', blocknum:4);
            blockread(datafile, filebuff[0], 1);
            blocknum := blocknum + 1;
            tries := 0;
          end;
        end
        else tries := tries + 1;
        if (inch <> can) and cts and not done then begin
          xmit(soh);
          xmit(lo(blocknum));
          xmit(255-lo(blocknum));
          chksum := 0;
          crc := 0;
          for loop := 0 to 127 do sendcalc(filebuff[0][loop]);
          calcCRC(0);
          calcCRC(0);
          if crcmode then begin xmit(hi(crc)); xmit(lo(crc)); end
            else xmit(chksum);
        end;
        if tries = 5 then crcmode := not crcmode;
      until (inch = can) or done or (tries= 10) or not cts;
      successful := done;
      tries := 0;
      if successful and cts then repeat
        xmit(eot);
        acknak(inch, 10);
        tries := tries + 1;
      until (inch=ack) or (tries > 10) or not cts;
      if cts and (inch <> can) and not successful then xmit(can);
      close(datafile);
      if successful then lineout(cr + lf + 'Download Successful! ')
                    else lineout(cr + lf + 'Download NOT Successful ');
    end;

  function recchar(var error: boolean): byte;
    var temp: byte;
    begin
      temp := 0;
      if not cts then error := true;
      if not error then begin
        if not timedin then error := true
        else begin
          temp := inbyte;
          calcCRC(temp);
          recchar := temp;
        end;
      end;
    end;

  procedure clearline;
    var junk: byte;
    begin
      while timedin do junk := inbyte;
    end;

{$I-}
  procedure upload(var successful: boolean);
    var
      blocknum, tries, byteloc        : integer;
      comp, locblock, crc2            : integer;
      fatal, error, done              : boolean;
      opening, inch, locrc            : byte;
      hicrc, csum2, mode              : byte;

    begin
      lineout('Beginning XMODEM protocol upload:');
      lineout('To cancel: type CTRL-X until you return to command prompt.');
      lineout('Hit RETURN when finished');
      tries := 0;
      done := false;
      opening := 0;
      locblock := 1;
      rewrite(datafile);
      fatal := ioresult > 0;
      if crcmode then mode := C else mode := nak;
      if cts and not fatal then fatal := not acknakout(mode);
      while cts and not (done or fatal) do begin
        tries := tries + 1;
        error := false;
        opening := recchar(error);
        if opening = can then fatal := true;
        if opening = eot then done := true;
        if (opening <> eot) and (opening <> soh) and not fatal
          then error := true;
        if cts and not (error or fatal or done) then begin
          blocknum := recchar(error);
          comp := recchar(error);
          if lo(comp + blocknum + opening) <> 0 then error := true;
          byteloc := 0;
          crc := 0;
          chksum := 0;
          while (byteloc < 128) and not (error or fatal) do begin
            filebuff[0][byteloc] := recchar(error);
            byteloc := byteloc + 1;
          end;
          if cts and not (error or fatal) then begin
            calcCRC(0);
            calcCRC(0);
            crc2 := crc;
            csum2 := chksum;
            hicrc := recchar(error);
            if crcmode then begin
              locrc := recchar(error);
              if (lo(crc2) <> locrc) or (hi(crc2) <> hicrc) then error := true;
            end else if csum2 <> hicrc then error := true;
            if (lo(locblock) <> blocknum)
              and (lo(locblock) <> lo(blocknum+1))
              and not error
              then fatal := true;
            if (lo(locblock) = blocknum) and not (error or fatal) then begin
              blockwrite(datafile, filebuff[0], 1);
              write(cr + ' Received #', locblock:5);
              if IOresult <> 0 then fatal := true;
              tries := 0;
              locblock := locblock + 1;
            end;
          end;
        end;
        if not (fatal or error) then purgeline else clearline;
        if done or not (error or fatal) then fatal := not acknakout(ack);
        if error and not fatal then begin
          fatal := not acknakout(nak);
          if tries > 6 then crcmode := not crcmode;
        end;
      end;
      if fatal then xmit(can);
      if done then xmit(ack);
      close(datafile);
      successful := (IOresult = 0) and done and not fatal;
      if not successful then erase(datafile);
      if successful then lineout(cr + lf + 'Upload Successful!');
    end;

  procedure storebuff(var buffernum: byte; var paused, aborted: boolean);
    var loop: byte;
    begin
      loop := 0;
      while (loop < buffernum) and not aborted do begin
        blockwrite(datafile, filebuff[loop], 1);
        if IOresult > 0 then aborted := true;
        loop := loop + 1;
      end;
      if buffernum in [1..16] then filebuff[0] := filebuff[buffernum];
      buffernum := 0;
      repeat xmit(17) until timedin;
      paused := false;
    end;

  procedure textcap(var successful: boolean);
    var
      buffernum, where, loop  : byte;
      cc, cz, paused          : boolean;
      withecho, done, aborted : boolean;
      temp                    : byte;
    begin
      withecho := (getcap('Do you want your text echoed (Y/N) ? ') = 'Y');
      lineout('Beginning text capture: 3 CTRL-Cs abort, 3 CTRL-Zs end.');
      cc := false;
      cz := false;
      done := false;
      paused := false;
      buffernum := 0;
      where := 0;
      rewrite(datafile);
      aborted := (IOresult > 0);
      while cts and not (done or aborted) do begin
        if paused then storebuff(buffernum, paused, aborted);
        temp := inbyte and $7f;
        if not cts then aborted := true;
        if withecho and outready then xmit(temp);
        write(chr(temp));
        if temp = 3 then begin if cc then aborted := true else cc := true; end
          else cc := false;
        if temp = 26
          then begin
            if cz
              then done := true
              else cz := true;
          end else cz := false;
        filebuff[buffernum][where] := temp;
        where := where + 1;
        if where > 127 then begin
          where := 0;
          buffernum := buffernum + 1;
        end;
        if buffernum > 14
          then begin
            paused := true;
            xmit(19);
          end;
        if buffernum > 16 then aborted := true;
      end;
      if done and cts and not aborted then begin
        buffernum := buffernum + 1;
        storebuff(buffernum, paused, aborted);
      end;
      close(datafile);
      if aborted and (IOresult = 0) then erase(datafile);
    successful := done and (IOresult=0) and not aborted;
    end;
{$I+}

  function exists(filename:line): boolean;
    var found: boolean;
    begin
      assign(datafile, filename);
      {$I-} reset(datafile) {$I+};
      found := (IOresult = 0);
      if found then close(datafile);
      exists := found;
    end;

  function alpha(filename:line): boolean;
    var strpos: integer;
        okay:   boolean;
        dots:   byte;
    begin
      dots := 0;
      okay := true;
      if length(filename) > 0 then
        for strpos := 1 to length(filename) do begin
          if filename[strpos] = '.' then dots := dots + 1;
          if not (filename[strpos] in ['.', '-', '_','#', '0'..'9', 'A'..'Z'])
            then okay := false;
        end;
      if dots > 1 then okay := false;
      alpha := okay;
    end;

  function getlegal: line;
    var filename:  line;
        dotpos: integer;
    begin
      repeat
        filename := allcaps(getinput('Enter name of file ? ', 13, echo));
        dotpos := pos('.', filename);
      until (((dotpos < 10) and (dotpos <> 1)
       and (not((dotpos = 0) and (length(filename) > 8)))
       and (not((dotpos > 0) and (length(filename) > dotpos + 3)))
       and alpha(filename)) or (filename = ''));
      getlegal := filename;
    end;

procedure listsections;
  var
    loopvar : integer;
    temp    : line;
  begin
    if cts then begin
      canstat := true;
      clearsc;
      lineout('File Sections:' + cr + lf);
      for loopvar := 1 to numfilesects do begin
        lineout(sect[loopvar].sectt);
      end;
      canstat := false;
    end;
  end;

  procedure getsect;
    var temp: integer;
        y : boolean;
        x,oldsect : byte;
  begin
      oldsect := sectnum;
      repeat
        temp := getint(numfilesects, 0, 'Which section (0 for list) ? ');
        if temp = 0 then listsections else sectnum := temp;
      until ((temp > 0) and (temp <= numfilesects)) or not cts;
      x := sect[sectnum].sect_access;
      y := (((sect[sectnum].spec_access and special_access) > 0) or
                 (sect[sectnum].spec_access = 0))  ;
      if not ((access >= x) and (y))
         then begin
           lineout('Access Restricted');
           sectnum := oldsect;
         end;
  end;

  function subdir : str40;
  begin
    subdir := sect[sectnum].secdir;
  end;

  Procedure update_file_dir(updatestr:line);
  var
    errcode : integer;
    dirfile : text;
  begin
    assign(dirfile,subdir + 'dir.bbs');
    {$I-}
    reset(dirfile);
    {$I+}
    errcode := ioresult;
    if errcode <> 0 then close(dirfile);
    if errcode = 0 then append(dirfile)
                   else rewrite(dirfile);
    writeln(dirfile,updatestr);
    close(dirfile);
  end;

  procedure addfile;
  var description : line;
    begin
        resetbuff;
        lineout(space);
        lineout('Please describe '+ filename + ' - (40 Characters)');
        lineout('  |---------------------------------------|');
        stringout('-> ');
        description := inputstring(echo,40);
        update_file_dir(filename + ' ' + description);
        update_userlog('UL = ' + filename + ' ' + description);
    end;

  procedure newfile(xmodem: boolean);
    var
      successful: boolean;
    begin
      clearsc;
        stringout('Upload: ');
        filename := getlegal;
        if filename <> '' then begin
          if exists(subdir + filename) then lineout('File name in use.')
          else begin
            assign(datafile, subdir + filename);
            if cts then begin
              if xmodem then upload(successful)
                else textcap(successful);
              if successful then addfile;
              clearline;
              if successful then uploads := uploads + 1
                else lineout('Fatal transfer error or disk full...');
            end;
          end;
        end;
    end;

  function legaltab(prompt: line): boolean;
    begin
      lineout(space);
      stringout(prompt);
      filename := getlegal;
      if ((filename <> '') and (exists(subdir + filename)))
         then begin
           legaltab := true;
           assign(datafile, subdir + filename);
         end
         else begin
           legaltab := false;
           lineout('No such file available.');
         end;
    end;

  procedure transmitfile;
    var
      successful,goodfile: boolean;
    begin
      if downloads >= (uploads * 4)
        then lineout('You MUST upload 1 file for every 4 you download!')
        else begin
          if legaltab('Download: ')
            then begin
              download(successful);
              if successful then
                begin
                  downloads := downloads + 1;
                  update_userlog('DL = ' + filename);
                end;
            end;
        end;
    end;

procedure textdump;
  begin
    if legaltab('ASCII text dump: ')
      then if filename <> ''
        then begin
          outfile(subdir + filename);
          if not cancelled
            then update_userlog('DL = ' + filename);
        end;
  end;

procedure disk_space(drive: CHAR);
var
  regs    :  regpack;
  fr,tr   :  REAL;
  temp    :  name;
BEGIN
    WITH regs DO BEGIN
        dx := ord(drive) - 64;
        ah := $36;
        MsDos(regs);                       { call function }
        fr := bx;
        IF ax > 0 THEN begin
          tr := fr * ax * cx;
          str(tr:8:0,temp);
          end
        ELSE temp:= '0'
    END;
lineout('Free Space: '+temp+' Bytes');
END; {disk_space}

TYPE
dta_type = record
         reserved : array[1..21] of byte;
             attr : byte;
             time : integer;
             date : integer;
          sizelo1 : byte;
          sizelo2 : byte;
           sizehi : integer;
            fname : array[1..13] of char;
         end;

dir_type = record
              attr : byte;
             fname : string[12];
               min : byte;
               hrs : byte;
               day : byte;
             month : byte;
              year : byte;
              size : real;
         end;

  str2   = string[2];
  str10  = string[10];
  str64  = string[64];
  str80  = string[80];

var
  dta_area      : dta_type;
  asciiz        : str64;
  dir_entries   : dir_type;

procedure set_dta;
var r : regpack;
begin
  r.ds := seg(dta_area);
  r.dx := ofs(dta_area);
  r.ah := $1a;
  msdos(r);
end;

function msdos4e(attrib:byte; stuff: line):boolean;
var r : regpack;
begin
  asciiz := stuff + #0;
  r.ds := seg(asciiz[1]);
  r.dx := ofs(asciiz[1]);
  r.cx := attrib;
  r.ah := $4e;
  msdos(r);
  msdos4e := (r.flags and 1) = 1;
end;

function msdos4f:boolean;
var r : regpack;
begin
  r.ah := $4f;
  msdos(r);
  msdos4f := (r.flags and 1) = 1;
end;

procedure showdta;
var   y  : byte;
    temp : str64;
begin
  temp := '            ';  { 12 spaces }
  y := 1;
  while dta_area.fname[y] <> #0 do
    begin
       temp[y] := dta_area.fname[y];
        y := y + 1;
     end;
  temp[0] := chr(y);
  dir_entries.fname := temp;
  dir_entries.size := dta_area.sizelo1 + dta_area.sizelo2 * 256.0
                    + dta_area.sizehi * 65536.0;
  dir_entries.year  := 80 + (dta_area.date shr 9);
  dir_entries.month := (dta_area.date and $1e0) shr 5;
  dir_entries.day   := (dta_area.date and $1f);
  dir_entries.hrs := dta_area.time shr 11;
  dir_entries.min := (dta_area.time shl 5) shr 10;
end;

function direct_find(findstr:line):boolean;
var err : boolean;
begin
  set_dta;
  err := msdos4e($3f,findstr);
  if not err then showdta;
  direct_find := not err;
end;

  procedure dir(action,yr,mo,dy:byte);
    var errcode, spos, spaces : integer;
        bksz : real;
        temps,tempt,filename : line;
        dirfile : text;
        any,found : boolean;
        blksize : string[10];
        test1,test2: real;
    begin
      any := false;
      found := false;
      lineout(space);
      assign(dirfile,subdir + 'Dir.bbs');
      {$I-}
      reset(dirfile);
      {$I+}
      errcode := ioresult;
      if errcode = 0
        then begin
          stringout('Directory: ');
          lineout('Section ' + sect[sectnum].sectt + ':');
            while (cts and (not cancelled) and (not eof(dirfile))) do
              begin
                readln(dirfile,temps);
                if copy(temps,1,1) = ' ' then lineout(temps)
                  else begin
                    if action = 1 then any := true;
                    spos := pos(' ',temps);
                    if spos = 0 then tempt := temps
                                else tempt := copy(temps,1,spos);
                    assign(datafile,subdir + tempt);
                    {$I-} reset(datafile); {$I+}
                    errcode := ioresult;
                    if errcode = 0
                      then begin
                        bksz := 128 * longfilesize(datafile);
                        str( bksz:7:0, blksize);
                        close(datafile);
                      end else blksize := 'MISSING';
                    if action = 2 then found := direct_find(subdir + tempt);
                    if ((action = 2) and (found = true)) then any := true;
                    while (length(tempt) < 13) do tempt := tempt + ' ';
                    if spos <> 0
                      then temps := copy(temps,spos,length(temps) - spos + 1)
                      else temps := '';
                    if action = 1  then lineout(tempt + blksize + temps)
                      else if action = 2 then begin
                        test1 :=  dir_entries.day + dir_entries.month*100.0 + dir_entries.year * 10000.0;
                        test2 :=  dy + mo * 100.0 + yr * 10000.0;
                        if ((test1 >= test2) and found )
                          then lineout(tempt + blksize + temps);
                      end;
                  end;
            end;
            close(dirfile);
         end else if not any then lineout('No files found.');
    end;

  procedure directory;
  var y : boolean;
      x : byte;
      inch: char;
      mo,dy,yr : byte;
    begin
      canstat := true;
      lineout(space);
      inch := getcap('<[A]ll>,[N]ew ? ');
      if not (inch in ['A','N']) then inch := 'A';
      case inch of
        'A' : dir(1,0,0,0);
        'N' : begin
                lineout(space);
                lineout('Directory of Files ON or AFTER : ');
                yr := getint(year,80,'  Year  <'+itoa(today_year)+'> ? ');
                if yr = 0 then yr := today_year;
                mo := getint(12,1,'  Month  <'+itoa(today_month)+'> ? ');
                if mo = 0 then mo := today_month;
                dy := getint(31,1,'  Day   <'+itoa(today_date)+'> ? ');
                if dy = 0 then dy := today_date;
                dir(2,yr,mo,dy);
              end;
      end; {case}
      canstat := false;
      disk_space('C');
    end;

  procedure killfile;
    var loop, tabloc: integer;
    dirfile, tempfile: text;
    temps : line;
    errcode : integer;
    begin
      if legaltab('Kill: ')
        then begin
          erase(datafile);
          assign(dirfile,subdir + 'DIR.BBS');
          assign(tempfile,subdir + 'temp.$$$');
          rewrite(tempfile);
          {$I-} reset(dirfile); {$I+}
          errcode := ioresult;
          if errcode = 0
            then begin
              readln(dirfile,temps);
              while not eof(dirfile) do
                begin
                if copy(temps,1,length(filename)) <> filename
                    then writeln(tempfile,temps);
                readln(dirfile,temps);
                end;
              if copy(temps,1,length(filename)) <> filename
                  then writeln(tempfile,temps);
              close(dirfile);
              erase(dirfile);
              close(tempfile);
              rename(tempfile,subdir + 'DIR.BBS');
            end;
        end;
    end;

  procedure installfile;
    begin
      if legaltab('Install : ') then
        if exists(subdir + filename)
          then begin
            addfile;
            lineout('File installed.');
          end;
    end;

  begin
    sectnum := 10;
    getsects;
    clearsc;
    repeat
      if not expert then outfile(filemenu);
      lineout(space);
      lineout('Location :# '+ sect[sectnum].sectt);
      comch := getcap('Files command (or ? for menu) ? ');
      case comch of
       '*' : getsect;
       'D' : directory;
       'S' : transmitfile;
       'T' : textdump;
       'H' : outfile(filehelp);
       '?' : outfile(filemenu);
       'C' : if access>newuser then begin crcmode := true; newfile(true); end;
       'X' : if access>newuser then begin crcmode := false; newfile(true); end;
       'A' : if access>newuser then newfile(false);
       'K' : if access = sysop then killfile;
       'I' : if access = sysop then installfile;
      end;
    until (comch = 'Q') or not cts;
  end;

procedure umess_store;
  begin
   lineout('Please enter message here - 40 char. max');
   lineout('|--------------------------------------|');
   stringout('->');
   umess := inputstring(echo,40);
   upost := true;
  end;

procedure command;
  var
    prompt: line;
    inch  : char;
    first : boolean;
    byby  : boolean;
  begin
    byby := false;
    first := true;
    while cts do begin
      canstat := false;
      calcconnect(usehour,usemin);
      if ((((usehour * 60) + today_timeon + usemin) > maxminon) and (access < prefuser))
        then begin
          lineout(space);
          connecttime;
          lineout('Sorry Swab, but you time Limit is up');
          lineout('Please Dematerialize NOW!');
          update_userlog('*** TIME EXPIRED ***');
          delay(5000);
          byby := true;
        end;
      if first and not expert then outfile(mainmenu);
      canstat := false;
      prompt := 'Command : ';
      if not expert
       then prompt := prompt + 'A,B,C,D,E,F,H,I,K,L,M,N,O,P,R,S,U,W,X,Y,#,* ? '
       else prompt := prompt + '(? for menu) ? ';
      lineout(space);
      if upost
       then WriteLn(umess)
       else begin
        umess := 'Welcome!';
        WriteLn(umess);
       end;
      lineout(space);
      lineout('Location : #' + sections[subboard].sectname);
      if byby then inch := 'D' else inch := getcap(prompt);
      first := true;
      case inch of
        'A': begin
               lineout('Leave mail to user 000');
               delay(1000);
               mail;
             end;
        'B': outfile(bulletin);
        'C': chat;
        'E': if access>newuser then umess_store else first := false;
        'N': enter;
        'F': filesys;
        'D': disconnect;
        'H': outfile(helpfile);
        'I': setvideo;
        'K': deletex;
        'L': userlog;
        'M': mail;
        'O': other_bbs;
        'P': newpass;
        'R': receive;
        'S': quickscan;
        'U': listusers;
        'W': outfile(welcome);
        'X': begin expert := not expert; first := false; end;
        'Y': outfile(sysinfo);
        '#': userstats;
        '*': change_decks;
        '?': if expert then outfile(mainmenu);
        '@': if access=sysop then sysoponly else first := false;
        else first := false;
      end; {case}
    end; {while cts}
  end; {command}

procedure defaults;
  begin
    inmail := false;
    chatsysop := false;
    mailsent := false;
    good_signon := false;
    textopen := false;
    fillchar(last_message,sizeof(last_message),0);
    real_name := space;
    address := space;
    town_city := space;
    state_zip := space;
    phone_number := space;
    downloads := 0;
    uploads := 0;
    messages_posted := 0;
    logged_on := 0;
    subboard := 1;
    lf := lnfd;
    bl := null;
    cs := cls;
    bs := bksp;
    expert := false;
    caps := false;
    width := 80;
    access := newuser;
    init_logon := '***';
    special_access := 0;
    last_time_on := '***';
    lastmess := 0;
    caller := space;
    usernum := 0;
    messopen := false;
    filesopen := false;
    printon := false;
    inbuffer := '';
    cancelled := false;
    controls := false;
    canstat := false;
    mail_sent := 0;
    mail_rec := 0;
    msg_nailed := 0;
    msg_read := 0;
    today_date := 0;
    today_timeon := 0;
  end;

begin
  comport := 1;
  set_rs232_vector;
  baud := 1200;
  stopbits := 1;
  databits := 8;
  parity := 'N';
  setup;
  exitchar := space;
  local := false;
  resetbuff;
  get_config;
  defaults;
  getsections;
  clearmodem;
  awaitcall;
  if exitchar <> abort then
  begin
    repeat
      setbordercolor(1);
      clock(year,onmonth, ondate, onhour, onmin);
      timeon := time(year,onmonth, ondate, onhour, onmin);
      purgeline;
      resetbuff;
      lineout('The Ghost Ship East ' + version);
      if cts and not cancelled then outfile(welcome);
      if cts then signon(caller);
      if cts and not cancelled then outfile(bulletin);
      readmine; {Looks for mail}
      if cts then initmess;
      if cts then command;
      if good_signon then savedefaults;
      writeln('hung up...');
      if textopen then closemess;
      endcall;
      defaults;
      clearmodem;
      setbordercolor(0);
      awaitcall;
      setbordercolor(1);
    until exitchar = abort;
  end;
  setbordercolor(0);

  case comport of                      { disable interrupts }
   1 : begin                           { and restore old vector }
         port[$21] := port[$21] or $10;
         int4 := oldvec;
       end;
   2 : begin
         port[$21] := port[$21] or $8;
         int3 := oldvec;
       end;
  end;

  PORT[base+4] := $2;
  halt(2);
end.